home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / gc.t < prev    next >
Text File  |  1990-06-15  |  10KB  |  303 lines
  1. (herald gc
  2.   (env tsys
  3.        (osys table)       ;; %TABLE-VECTOR must be integrated here
  4.        (osys gc_weak)))   ;; for the GC-WEAK-???-LISTs
  5.  
  6. (define-integrable (in-old-space? obj)
  7.   (and (fx>= obj (system-global slink/old-space-begin))
  8.        (fx< obj (system-global slink/old-space-frontier))))
  9.  
  10. ;;; True if an object is in new space.
  11. (define-integrable (in-new-space? obj)
  12.   (and (fx>= obj (system-global slink/area-begin))
  13.        (fx< obj (system-global slink/area-frontier))))
  14.  
  15.  
  16. (define-integrable (maybe-copy-object obj)
  17.   (if (not (in-old-space? obj))
  18.       obj
  19.       (select (descriptor-tag obj)
  20.     ((tag/fixnum tag/immediate)
  21.      obj)
  22.     ((tag/pair)
  23.      (maybe-copy-pair obj))
  24.     (else                ;extend
  25.      (maybe-copy-extend obj)))))
  26.  
  27. (define (maybe-copy-extend obj)
  28.   (let ((header (extend-header obj)))
  29.     (cond ((immediate? header)
  30.        (copy-immediate-object obj header))
  31.       ((not (extend? header))
  32.        (gc-error-message "corrupt header" obj)
  33.        obj)
  34.       ((in-new-space? header)
  35.        header)            ;forward
  36.       (else
  37.        (copy-closure obj header)))))
  38.  
  39. (define (maybe-copy-pair obj)
  40.   (let ((forward (cdr obj)))
  41.     (if (and (list? forward) (in-new-space? forward))
  42.     forward
  43.     (gc-copy-pair obj))))
  44.  
  45.  
  46. (define (copy-closure obj template)
  47.   (cond ((template-internal-bit? template)
  48.      (let* ((encloser (maybe-copy-object (closure-enclosing-object obj)))
  49.         (offset    (closure-encloser-offset obj)))
  50.        (make-pointer encloser (fx- offset 1))))
  51.           (else
  52.            (let* ((ptrs (template-pointer-slots template))
  53.                   (size (fx+ ptrs (template-scratch-slots template))))
  54.              (gc-copy-extend obj size)))))
  55.  
  56.  
  57.  
  58. (define (gc-copy-template obj)
  59.   (let* ((encloser (maybe-copy-object (template-enclosing-object obj)))
  60.      (offset   (template-encloser-offset  obj)))
  61.     (make-pointer encloser (fx- offset 1))))
  62.  
  63.  
  64. ;;;   Find out whether a value has been copied into the new heap and return a
  65. ;;; a flag and the new location.  The flag is true if the object was indeed
  66. ;;; retained.  This is a simpler version of MOVE-OBJECT.  Symbols are always
  67. ;;; copied.
  68.  
  69. (define (get-new-copy obj)
  70.     (if (not (in-old-space? obj))
  71.         (return t obj)
  72.         (xselect (descriptor-tag obj)
  73.           ((tag/fixnum tag/immediate)
  74.            (return t obj))
  75.           ((tag/pair)
  76.            (if (and (list? (cdr obj)) (in-new-space? (cdr obj)))
  77.                (return t (cdr obj))
  78.                (return nil nil)))
  79.           ((tag/extend)
  80.            (let ((header (extend-header obj)))
  81.               (cond ((extend? header)
  82.                      (get-new-extend-copy obj header))
  83.                     ((symbol? obj)
  84.                      (return t (gc-copy-object obj)))
  85.                     (else
  86.                      (return nil nil))))))))
  87.  
  88. (define (get-new-extend-copy obj header)
  89.   (cond ((template-header? header)   ; 68000 requires this first
  90.          (receive (traced? new-loc)
  91.                   (get-new-copy (template-enclosing-object obj))
  92.            (if traced?
  93.                (return t (make-pointer new-loc
  94.                                        (fx- (template-encloser-offset obj) 1)))
  95.                (return nil nil))))
  96.         ((in-new-space? header)
  97.          (return t (extend-header obj)))
  98.         ((template-internal-bit? header)
  99.          (receive (traced? new-loc)
  100.                   (get-new-copy (closure-enclosing-object obj))
  101.            (if traced?
  102.                (return t (make-pointer new-loc
  103.                                         (fx- (closure-encloser-offset obj) 1)))
  104.                (return nil nil))))
  105.         (else
  106.          (return nil nil))))
  107.  
  108. ;;; Copy an object and return the new pointer
  109.  
  110.  
  111. (define (gc-copy-object thing)
  112.   (let* ((begin (system-global slink/area-frontier))
  113.      (new (maybe-copy-object thing)))
  114.     (gc-scan-heap (gc-extend->pair (gc-extend->pair begin))
  115.            (lambda () (system-global slink/area-frontier)))
  116.     new))
  117.  
  118. ;;; Moving immediates
  119. (define-local-syntax (fx header)
  120.   `(fixnum-ashr ,header 2))
  121.  
  122. (define (copy-immediate-object obj header)
  123.   (select (header-type header)
  124.     (((fx header/text) (fx header/symbol) (fx header/bytev))
  125.      (gc-copy-extend obj (bytev-cells obj)))
  126.     (((fx header/general-vector) (fx header/unit) (fx header/bignum) (fx header/stack))
  127.      (gc-copy-extend obj (vector-length obj)))
  128.     (((fx header/slice) (fx header/foreign) (fx header/double-float)
  129.             (fx header/weak-table))
  130.      (gc-copy-extend obj 2))
  131.     (((fx header/cell) (fx header/weak-set) (fx header/weak-alist)
  132.             (fx header/weak-cell))
  133.      (gc-copy-extend obj 1))
  134.     (((fx header/template))
  135.      (gc-copy-template obj))
  136.     (((fx header/vcell))
  137.       (gc-copy-extend obj %%vcell-size))
  138.     (((fx header/char) 20 (fx header/true) (fx header/interrupt-frame)
  139.                (fx header/double-float-vector) (fx header/single-float)
  140.                (fx header/ratio) (fx header/complex)
  141.                (fx header/fault-frame) 15 (fx header/task)
  142.                25 27 29 31)
  143.      (gc-error-message "no method for an immediate" obj)
  144.      obj)))
  145.      
  146.  
  147.  
  148. ;;; Three little utilities.
  149. #|
  150. (define (gc-copy-pair pair)
  151.   (gc-count-message)
  152.   (let ((new (cons (car pair) (cdr pair))))
  153.     (set (cdr pair) new)
  154.     new))
  155.  
  156. (define (gc-copy-extend obj size)
  157.   (gc-count-message)
  158.   (let ((new (%make-extend (extend-header obj) size)))
  159.     (%copy-extend new obj size)
  160.     (set (extend-header obj) new)
  161.     new))
  162. |#
  163.  
  164. (define (gc-copy-pair pair)
  165.   (lap ()
  166.     (load l (d@nil slink/area-frontier) a2)
  167.     (add ($ 8) a2)
  168.     (store l a2 (d@nil slink/area-frontier))
  169.     (sub ($ 5) a2)
  170.     (load l (d@r a1 %%car) a4)
  171.     (store l a4 (d@r a2 %%car))
  172.     (load l (d@r a1 %%cdr) a4)
  173.     (store l a4 (d@r a2 %%cdr))
  174.     (store l a2 (d@r a1 %%cdr))
  175.     (jr link-reg)
  176.     (move a2 a1)))
  177.  
  178. (define (gc-copy-extend obj size)
  179.   (lap ()
  180.     (load l (d@nil slink/area-frontier) a3)
  181.     (add ($ 4) a3)
  182.     (add a2 a3 a4)
  183.     (store l a4 (d@nil slink/area-frontier))
  184.     (add ($ 2) a1 a2)
  185.     (sub ($ 2) a3 a1)
  186.     (load l (d@r a2 -4) a5)
  187.     (store l a5 (d@r a3 -4))
  188.     (store l a1 (d@r a2 -4))
  189.     (jbr copy-loop-top)
  190. copy-loop
  191.     (load l (d@r a2 0) a5)
  192.     (store l a5 (d@r a3 0))
  193.     (add ($ 4) a2)
  194.     (add ($ 4) a3)
  195. copy-loop-top
  196.     (j< a3 a4 copy-loop)
  197.     (jr link-reg)
  198.     (noop)))
  199.  
  200.  
  201. (define-integrable (bytev-cells bytev)
  202.   (fixnum-ashr (fx+ (bytev-length bytev) 3) 2))
  203.  
  204. (define (gc-scan-active-heap)
  205.   (gc-scan-heap (gc-extend->pair (gc-extend->pair 
  206.                      (system-global slink/area-begin)))
  207.          (lambda () (system-global slink/area-frontier))))
  208.  
  209. (define (gc-scan-initial-impure-area)
  210.   (gc-scan-heap (system-global slink/initial-impure-base)
  211.              (lambda () (system-global slink/initial-impure-memory-end))))
  212.  
  213.  
  214. (define-integrable (gc-scan-heap start stop)
  215.   (iterate loop ((obj start))
  216.     (cond ((fx>= obj (stop)))
  217.       (else
  218.        (let ((header (extend-header obj)))
  219.          (cond ((immediate? header)
  220.             (select (header-type header)
  221.               (((fx header/char) (fx header/true))
  222.                (set (extend-header obj) (maybe-copy-object header)) ;cdr
  223.                (modify (extend-elt obj 0) maybe-copy-object) ;car
  224.                (loop (make-pointer obj 1)))
  225.               (((fx header/stack))
  226.                (gc-scan-stack (make-pointer obj 0)
  227.                       (fx+ (descriptor->fixnum obj)
  228.                        (fx- (stack-length obj) 1)))
  229.                (loop (make-pointer obj (stack-length obj))))
  230.               (((fx header/text) (fx header/symbol) (fx header/bytev))
  231.                (loop (make-pointer obj (bytev-cells obj))))
  232.               (((fx header/general-vector) (fx header/unit))
  233.                (let ((len (vector-length obj)))
  234.              (do ((i 0 (fx+ i 1)))
  235.                  ((fx>= i len) (loop (make-pointer obj len)))
  236.                (modify (extend-elt obj i) maybe-copy-object))))
  237.               (((fx header/bignum))
  238.             (loop (make-pointer obj (bignum-length obj))))
  239.               (((fx header/slice) (fx header/foreign))
  240.                (modify (extend-elt obj 0) maybe-copy-object)
  241.                (loop (make-pointer obj 2)))
  242.               (((fx header/double-float))
  243.                (loop (make-pointer obj 2)))
  244.               (((fx header/weak-table))
  245.                (cond ((weak-semaphore-set? obj)
  246.                   (modify (extend-elt obj 1) maybe-copy-object))
  247.                  (else
  248.                   (exchange (weak-table-vector obj)
  249.                     (%table-vector (weak-table-table obj)))
  250.                   (set (extend-header obj) (gc-weak-table-list))
  251.                   (set (gc-weak-table-list) obj)))
  252.                (modify (extend-elt obj 0) maybe-copy-object)
  253.                (loop (make-pointer obj 2)))
  254.               (((fx header/cell))
  255.                (modify (extend-elt obj 0) maybe-copy-object)
  256.                (loop (make-pointer obj 1)))
  257.               (((fx header/weak-cell))
  258.                (set (weak-cell-contents obj) '#f)
  259.                (loop (make-pointer obj 1)))
  260.               (((fx header/weak-set))
  261.                (cond ((weak-semaphore-set? obj)
  262.                   (modify (extend-elt obj 0) maybe-copy-object))
  263.                   (else
  264.                    (set (extend-header obj) (gc-weak-set-list))
  265.                    (set (gc-weak-set-list) obj)))
  266.                (loop (make-pointer obj 1)))
  267.               (((fx header/weak-alist))
  268.                (cond ((weak-semaphore-set? obj)
  269.                   (modify (extend-elt obj 0) maybe-copy-object))
  270.                   (else
  271.                    (set (extend-header obj) (gc-weak-alist-list))
  272.                    (set (gc-weak-alist-list) obj)))
  273.                (loop (make-pointer obj 1)))
  274.               (((fx header/vcell))
  275.                (modify (extend-elt obj 0) maybe-copy-object)
  276.                (modify (extend-elt obj 1) maybe-copy-object)
  277.                (modify (extend-elt obj 2) maybe-copy-object)
  278.                (modify (extend-elt obj 3) maybe-copy-object)
  279.                (loop (make-pointer obj 4)))
  280.               (((fx header/template) 20 (fx header/interrupt-frame)
  281.                (fx header/double-float-vector) (fx header/single-float)
  282.                (fx header/ratio) (fx header/complex)
  283.                (fx header/fault-frame) 15 (fx header/task)
  284.                25 27 29 31)
  285.                (gc-error-message "Bad immediate in scan"))))
  286.            ((template? header)
  287.             (set (extend-header obj)
  288.              (maybe-copy-object header))
  289.             (let ((p (template-pointer-slots header)))
  290.               (do ((i 0 (fx+ i 1)))
  291.               ((fx>= i p) (loop (make-pointer 
  292.                          obj 
  293.                          (fx+ p (template-scratch-slots header)))))
  294.             (modify (extend-elt obj i) maybe-copy-object))))
  295.            (else
  296.             (set (extend-header obj) (maybe-copy-object header)) ;cdr
  297.             (modify (extend-elt obj 0) maybe-copy-object) ;car
  298.             (loop (make-pointer obj 1)))))))))
  299.  
  300.  
  301.  
  302.  
  303.